BMUG Revelations/BMUG Revelations.toast/Programming/Programming Languages/Yerk 3.64/System source/Class

Text File | 1993-06-07 | 18KB | 600 lines

\ Class/Object general properties and compilation code
\  4/26/84  CBD Version 1.0
\  4/26/84  CBD Speeded up ^Elem and friends
\  4/27/84  CBD Moved rect, etc. to QD  file
\  5/02/84  CBD Removed IX-non-IX restriction
\  5/24/84  NDI Remove selector numbering, add objlen
\  5/26/84  CBD Took non-class stuff out
\  5/28/84  CBD Selectors defer refs to input parm objects
\ 10/04/84  CBD Added class initialization, text messages
\ 10/11/84  CBD objPtr and objArray support
\ 10/12/84  CBD Added GET: and PUT: for arrays
\ 10/18/84  CBD converted to mcfa Values
\ 10/30/84  CBD propagate classInit: thru Ivar chains at create
\ 11/02/84  CBD objects have executable CFA
\ 11/02/84  CBD update for optimized array support in nucleus
\ 11/16/84  CBD removed objArray, etc.
\ 12/08/84  CBD ß1.0 version
\ 12/14/84  cbd removed read:, write:, etc
\ 12/15/84  cbd hashed selectors
\ 12/12/85  cdn Put CR after redefined message in :M
\  8/01/86  cdn Added "Method redefined, within same class ****" message
\ 12/27/89    rfl    changed ?isclass to check for valid ram for @
\  1/11/90    rfl    need to change traverse or at least ?cfa in nuc to protect for valid ram
\ 11/23/90    rfl    Method redefined message now comes before selector for readability
\ 12/17/90    rfl    added class name to above
\  6/01/91    rfl    ovblock modified for sys 7...heap is below 0;
\ 12/12/92    rfl 32 bit hash for methods; move ?rdepth to this source
\ 12/25/92    rfl    changed nuc to set heapBot, heapTop in relative addr space
\ 12/26/92    rfl object name not unique error gives name of object
\  5/28/93    rfl    added within and used it in (@)
\  6/04/93    rfl    modified (build) for source documentation (line#..)

0 value (rdepth)
: +rdepth 1 -> (rdepth) ;
: -rdepth 0 -> (rdepth) ;
: ?Rdepth (rdepth) IF  rdepth  220 > ?error 116 THEN ;

: +docs true -> docs ;
: -docs false -> docs ;

: ^CLASS   current  @ pfa ;

\ the following offsets refer to the ^class, or Pfa of the class.
: MFA    10 + ;    \ methods dictionary Latest field
: IFA    14 + ;    \ ivar dict Latest field
: DFA    18 + ;    \ Datalen , width of indexed area
: SFA    22 + ;    \ superclass ptr field

\ Get length of object's named ivars
: @DLEN cfa @ Dfa  W@   ;

\ ( SelPfa ^class -- m1cfa )  Find a method in a class
: (FINDM)
    swap over mfa ((findm))  0=
    IF  cr msg# 108  nfa .name
        abort
    ELSE  swap drop THEN ;

\ ( Selhash objPfa -- objPfa m1cfa )
\  Find a method 1cfa given a selector ID
: FIND-METHOD
    dup 0= ?error 103
    swap over CFA @ (FINDM)  ;

\ ( objAddr -- )  Look up SelID at IP and run the method
: (Defer)
    w@(ip)    \ objPfa  selID
    Swap  Find-Method Cfa    \ objAddr m0cfa
    execute  ;    \ exec the  m0cfa

   0 Value  ^Self
   0 Value  ^Super        \ nfa of SUPER pseudo-Ivar
   0 Value  newObject    \ object being created
   1 Value  rangeCheck    \ true if runtime range check desired
true Value dEcho        \ echo load to screen?

0 -> quitvec    \ clear vectors
0 -> abortvec
0 -> objInit
'c pfind -> ufind

\ ( addr -- hashVal )  hash a  name into a 16-bit word
: Hash { addr -- }
    0 addr count +  addr
    DO 4* Dup 65535 > IF 1+ THEN
        I  C@ 32 - xor  65535 And
    LOOP ;

: within { n lo hi -- b } n lo >= n hi <= and ;

\ check to make sure the memory addressed is within the application heap zone
: (@) ( addr -- n t or f)  dup heapBot heapTop within
    IF @ true ELSE drop false THEN ;

\ ( pfa -- pfa b )  returns true if a class -  make sure pfa points within appl
: ?IsClass  'CODE DoClass OVER CFA (@) IF = ELSE drop false THEN ;

\ ( pfa -- pfa b )  return true if an object
:f ?IsObj
    ?IsClass
    IF  False
    ELSE Dup cfa (@)
        IF ?IsClass swap drop ELSE false THEN
    THEN ;f

\ ( pfa -- pfa b )  return true if an object vector
: ?IsVect  dup cfa (@) IF  valCode = over cfa @ vectCode = or ELSE false THEN ;

\ ( pfa -- pfa b )  is ref'd word an open bracket?
: ?IsParen  dup nfa 1+ c@ ascii [ =  ;

\ ( -- )  ERROR if not compiling a new class definition
: ?Class   Cstate   0=  ?error 115  ;

\ ( classIFA -- f OR 1cfa t )  search CLASS dictionaries
: ivarFind   here hash swap ((findm))   ;

\ ( -- f OR pfa t )  Determine if  next word is an instance var
: vFind
    bl word  Cstate
    IF    \ class compile?
        ^class  IFA ivarFind    \ search IVAR chain
    ELSE  0 THEN ;    \ leave ff

\ Key to instantiation actions
\ notFnd    -not previously defined
\ objTyp    -defined as an object
\ classTyp    -as a class
\ vecTyp    -as an object vector- ptr, array, etc
\ parmTyp    -as a named parm
\ parenType    -open paren for defer group

\ ( #elems ^class  OR ^class -- indlen )
: IDX-HDR   DFA 2+ W@ DUP IF  2DUP W, W,  * align THEN ;

\ ( IVnfa -- ivlfa )
: ilfa   2+ ;

\ ( ilfa -- icfa )
: ^ICLASS  CFALEN + @ ;

\ ( ^class -- elWidth )  return the indexed element width for class
: @width   dfa 2+ w@  ;

\ ( infa -- icfa )  transform ivar nfa to its class field
: icfa  ilfa  4+  ;

\ ( ivarlfa -- #els  wid  idxOffs  tf OR ff )

\ ( ivarNfa -- IvarNfa b )  True if nfa is Super or Self
: ?LastIvar         Dup  ^Self   = Over ^Super   = OR ;

\ InitIvar  performs the classInit: method on the ivar on the stack )
Forward InitIvar

\ ( ivarNfa -- latestNfa )  -> Latest nested Ivar
: ^LatestIvar    ilfa ^Iclass  IFA  @  ;
: ^NextIvar      ILFA  @ ;

\ ( ivarnfa -- ivoffs )  Return ivar's offset
: @IvarOffs  ILFA  8+ W@  ;

\ ( ivarNfa -- IvarNfa newNfa t  OR  ivarNfa f )
: ?Nest
    Dup ^LatestIvar  ?LastIvar
    IF  Drop 0 ELSE 1 THEN ;

\ ITRAV traverses the tree of nested ivar definitions in a
\ class, building necessary indexed area headers
\ the Mstack has the base offset for nested Ivars
\ ( ivarNfa -- )
: ITRAV
    BEGIN  ?Rdepth ?Nest
        IF Over @IvarOffs Dupm Addm Itrav THEN
        Dup
        ILFA dup    \ DO-NODE - Build header if indexed ivar
        pushm copym ^iclass -dup    \ HDR-INFO
        IF  copym $ 0a + w@  popm 8+ w@   ( #els  offs )
            rot dup dfa w@ rot + swap @width  ( #els truoffs wdth)
            swap over -dup
            IF ELSE 2drop drop 0 THEN
        ELSE  dropm 0 THEN    \ not idx
        IF  CopyM +    \ add in nested base offset
            pushm copym newObject  + w!   ( ! el-width )
            popm  newObject  +  2+ W!  ( !  # els )
            dup 4+ @        \ get ^class of indexed Ivar
            over 8+ w@        \ get offs this ivar
            copym  newObject + + cfa !    \ store in cfa
        THEN  initIvar
        ^NextIvar  ?LastIvar  Not
    WHILE  REPEAT
    DROP DropM ;

Forward  ClassInit

\ ( #elems ^class OR ^class -- ) Compile an instance variable dictionary entry
: <VAR
    pushm    \ place ^class on methods stack for later
    Vfind  ?error 117
    here dup hash w,        \ compile hashed ivar name into dict
    ^Class IFA dup @ ,  !  COPYM  ,  ( link, class )
    copym @width
    IF  4 ^class dfa w+! THEN    \ if indexed, save 4 for cfa
    ^Class DFA  W@  W,            \  ( current dLen= offset )
    copym @width dup
    IF over * swap W, 4+ THEN  ( #elems)
    popM DFA W@  +  align    \ Account for named ivar lengths
    ^Class  DFA   W+!   ;

\ ( -- )  Create hdr for the name at Here
: CreateHdr
    Here 1+ c@ 0= ?error 118
    $ 80 S, latest , current !  0,   ;

\ ( m1cfa n -- )  Execute the ncfa of word on stack
\ takes a standard Pfa = 1cfa as input
\ : mExec  clen * swap 4- + Execute ;

\ ( #elems ^class OR ^class -- )  Build an instance of a class
: (BUILD)
    Pushm  Cstate
    IF  Popm  <Var    \ build an ivar
    ELSE
        \ NEWTOKEN : pulls name from stream
        Here 1 and IF 0 c, THEN docs IF line# w, THEN Find
        IF drop ?isVect
            IF  3 ( vecTyp )
            ELSE  1 ( objTyp )
            THEN
        ELSE 0 ( notFnd ) THEN    ( -- pfa type OR 0 )

        \ OBJHDR :
        \ Build a public  object header or just a cfa if headerless
        \ If an object vector, load pfa of object into vector
        \ ( {vectPfa} objType -- )  HERE is left at pfa of new object
        Select{    \ on object type
            0 ( notFnd )    Is{  CreateHdr  }End    \ not redefined

            1 ( objTyp )    Is{  drop createHdr
                type# 181 ( Object name not unique ) latest id.  cr   }End

            2 ( classtyp )  Is{ abort }End        \ should not get this

            \ ( ind vecPfa -- )  for object vectors, execute -> code at 2cfa
            3 ( vecTyp )   Is{  0, Here  swap 2 clen * swap 4- + Execute
                msg# 120  }End

        Default{ abort }Select

        Here  -> newObject
        Copym here  cLen - !    \ store ^class
        copym  DFA  W@            ( dfa datalen )
        Reserve        \ allocate named instances
        copym  IDX-HDR  reserve
        popm IFA @  ?LastIVar not
        IF  0 Pushm Itrav ELSE drop THEN
        classInit
    THEN  ;

\ yerk grow zone function
'c null vect growZone

\ ( size -- addr )  acquire a block of nonrelocatable heap
: ovBlock { size -- addr }
    size  newPtr  dup +base 0=
    IF  drop growZone  size newPtr dup +base 0=
        ?error 121
    THEN ;

\ build a new object on the heap for class. Use: Heap> className
\ gets heap, and returns  relative  ptr
: (heapObj) { theClass \ dLen obAddr idWid #els -- } 0 -> #els
    theClass dfa w@ -> dlen  theClass dfa 2+ w@ -> idWid
    idWid  IF -> #els THEN
    dLen 4+ idWid IF  idWid #els * 4+ + THEN    \ get total length of obj
    ovBlock  4+ -> obAddr    \ get nonReloc heap, save ptr to cfa
    theClass obAddr cfa !    \ create the class ptr
    idWid  IF  idWid  obAddr dLen + w!  #els obAddr dLen + 2+ w! THEN
    obAddr -> newObject  theClass ifa @  ?LastIvar not
    IF 0 PushM Itrav ELSE Drop THEN classinit obAddr   ;

: heap>
    @pfa ?isClass not ?error 122
    state
    IF  Compile lit  ,
        Compile (heapObj) ELSE (heapObj)
    THEN
; Immediate

\ ( -- )  Set CSTATE to compiling a class
: ]C  1 -> Cstate ; Immediate
: C[  0 -> Cstate ; Immediate

\ compile hashed word for name at Here
: hash,  @word hash w,  ;

$ 81FE0000 variable  aName  0 W,    \ fake name/link

\ ( -- )  The super class of Object - top of all inheritance
: Meta
    <[  'Code doClass ^Class CFA !
    here 10 allot  'code objmp swap 10 cmove    \ jump to object code
    aName ,        \ latest method pointer
    0,            \ latest ivar pointer -> SUPER
    0,   ( data len, flags)
    0,   ( super pointer)  HERE -> ^SELF
    hash, SELF    \ SELF ivar
    0, 0, 65535 W,     ( link, ^class, offset)
    Here  -> ^Super    \ save this address for later
    hash, SUPER
    ^self , 0, 65535 W,   ( link, ^class, offset )

^super ' meta ifa !

\ ( -- )  Build a class header with its superclass pointer
: <Super
    @pfa dup        \ find the superclass
    dup  ^Super icfa !    \ store superclass in SUPER
    CFA here CFA    \ Set up for cmove to sub class
    26 Cmove        \ create image of superclass header
    ^Class SFA !    \ store superclass pointer
    ^Class  ^Self icfa !    \ store ^class in SELF's icfa
    26 allot
    [Compile]  ]C [Compile]   <[    \ in class, interpret
; Immediate

'c copym Vect caller    \ late bound reference to calling object

\ ( -- b )  true if word at Here is a selector xxx:
: ?isSel  here count 1- + c@ ascii :  =  here c@ 1 > And ;

\ get a selector from the input stream
: getSelect
    @word dup c@ 15 >
    ?error 123
    ?isSel 0= ?error 124
    hash  ;

\ ( -- )  Build a methods dictionary entry for selector
: :M { \ selID -- }
    ?Class  !Csp  [Compile] ]>
    getSelect -> selID
    selID ^class mfa ((findm))    \ is method already defined?
    IF  type# 182 here count type  ( Method redefined )
        space latest id.            \ add class name
        ^class > IF type# 183 ( , within same class **** ) THEN cr
    THEN
    here  selID w,        \ name is selector's hashed value
    ^class mfa dup @    \ get  mfa, old link
    ,  !    \ establish the links
    \ build methods cfas
    'Code  M0CFA ,  'Code M1CFA ,
; Immediate

\ ( -- pfa tokenID )  Determine type of token referenced by selector.
: refToken
    uFind    \ look for named stack parm
    IF  drop  4 ( parmTyp )
    ELSE  here latest (find)  0=
        ?error 125  drop  ?IsClass
        IF  2 ( classTyp )
        ELSE  ?IsVect
            IF  3 ( vecTyp )
            ELSE  ?IsObj
                IF  1 ( objTyp )
                ELSE  ?IsParen
                    IF  5 ( parenType )
                    ELSE  1 ?error 126
                    THEN
                THEN
            THEN
        THEN
    THEN  ;

\ ( objpfa -- a:datalen )
: ^dlen   cfa @ dfa ;

\ ( ivarPfa  m1cfa )  compile an Ivar reference
: ivar,    ,   w@ w,   ;    \ | 1cfa | offs |

\ ( objPfa  m0cfa )  compile an object ref
: obj,   swap cfa , ,  ;    \ | objCfa | m0cfa |

\ ( selID ivPFa )
: ivarRef    Find-Method ivar,   ;

\ ( selID -- )  Build a reference to an object or vector
: objRef  refToken
    SELECT{
        0 ( notFnd )    IS{   abort  }END

        ( selID objPfa -- )
        1 ( objTyp )    IS{ cfa execute
            Find-Method cfa obj,   }END    \ normal obj ref

        2 ( classTyp )  IS{   (FINDM) cfa ,  }END    \ compile m0cfa

        ( selPfa  vecPfa -- )
        3 ( vecTyp )    IS{  cfa , Compile (defer) w,  }END

        4 ( parmTyp )   IS{  cfa  ,    \ named parm- compile the pickCfa
            Compile (Defer) W, }END    \ auto deferred

        5 ( parenType ) IS{  drop pushM  251   }END    \ paren'd defer group

    DEFAULT{  abort
    }SELECT  ;

\ ( selPfa -- )  Execute using token in stream
: runRef
    @Pfa  drop  refToken
    Select{
        0 ( notFnd )     Is{  abort   }End
        1 ( objTyp )     Is{  cfa execute  Find-Method    }End
        2 ( classTyp )   Is{  (Findm)    }End

        ( selID  vecPfa -- )
        3 ( vecTyp )     Is{  cfa execute  Find-Method    }End

        4 ( parmTyp )    Is{ abort    }End

        \ open bracket denotes a deferred ref to what
        \ the paren'd group puts on the stack at runtime
        5 ( parenType )  Is{  drop  Pushm ' null  }End

    Default{ abort
    }Select  cfa  execute ;    \ execute the object, m0cfa

\ ================= Selector support ==========================
\ message is the message compiler invoked by using a selector
: message
    state
    IF    \ Compile state
        VFIND    \ instance variable?
        IF   ivarRef    \ ivar reference
        ELSE   objRef    \ compile object/vector reference
        THEN
    ELSE runRef    \ run state - execute object/vector ref
    THEN
; Immediate

\ if parsed word is a message selector, leave cfa of message compiler
\ ( -- selID msgPfa 0 t OR f )
: msgFind
    ?isSel
    IF  Here hash    \ leave selID
        ' message $ c1 true
    ELSE  pfind        \ look for named parms
    THEN   ;

'c msgFind -> Ufind

\ Force late binding of method to object, as in SmallTalk
\ a close bracket pops the last selID from the methods stack and
\ compiles a defer: selID.  This will build a deferred reference to the
\ parenthesized group.
: ]    State
    IF  251 ?Pairs  Compile (Defer)
        mdepth 0= ?error 127
        popM   W,    \ Compile | {defer} |SelPfa|
    ELSE  popM  Swap   Find-Method Cfa    \ exec state
        execute
    THEN
; Immediate

\ left bracket has no meaning unless preceded by a selector.
: [  true ?error 128  ; Immediate

: ;M   ?Csp  Compile  (;M)   ;  Immediate

\ Leave class compilation state, and zero the class ptrs of Self and Super
: ;Class  [Compile] <[  [Compile] C[
        0  ^Super icfa !   0 ^Self icfa !  ;  Immediate

: :Class    [Compile] :    ; Immediate

\ ( width -- )  Set a class and its subclasses to indexed
: <Indexed  ?class ^class DFA 2+ W! ;

\ ( dim -- )  Set an indexed class to a multi-dimensionality
\ : <Dim
\    ?class ^class DFA 2+ W@ 0= ?error 175    \ misuse of <Dim
\    ^class DFA 2+ c! ;

\ ( index -- addr ) ( dlen ^base -M- dlen ^base )  range check
: ?Range    dup 0< >R range? R> or ClassErr" 129  ;

\ ( index -- addr )  Return pointer to indexed  element #
: ^Elem
    ?Class    RangeCheck
    IF Compile ?range  THEN
    Compile (^elem)   ;  Immediate

\ An object's base addr is always on top of mstack
Create ^base    \ make code word alias
    'Code copym here cfa !

\ length does not include cfa
\ ( -- objlen )  compute total length of object
\ - requires obj addr on mstack
: objlen
    copym @dlen copym ^dlen 2+ w@ -dup
    IF idxBase 2- w@ * + 4+ THEN ;

\ Define  class init routine
:F classInit    classinit: newObject   ;F

\ ( ^ivarLfa -- ) ( ivarOffs -M- )
getSelect classInit: Constant initID
:F initIvar
    initID swap 8+    \ ( selID ivPfa )
    dup cfa @        \ non-0 ^class?
    IF  Find-Method cfa swap W@    ( 0cfa ivOffs )
        copym newObject + +        ( 0cfa ^data )
        swap execute            \ execute the 0cfa
    ELSE  2drop        \ don't try to init Self or Super
    THEN   ;F

\ clean up class compiler data on an Abort
' ;class cfa -> abortVec

\ dump will be in the Util module
Forward dmp

\ install object builder
' (build) cfa -> bldvec

\ ( -- )  error if object is not indexed
: ?ixObj
    copym  4- @  ?IsClass not swap
    dfa 2+ w@ 0= or classErr" 130 ;

: ?ixRange   ?IxObj  ?range  ;
'c ?ixRange vect ?idx

: +range  'c ?ixRange -> ?idx  ;
: -range  'c null -> ?idx ;    \ no range checking

:CLASS Object  <Super Meta

    :M  AT:    ?idx  At4    ;M   ( index -- val )
    :M  TO:    ?Idx  (^elem) !    ;M   ( val Index -- )
    :M  +TO:   ?idx  ++4   ;M   ( incVal index -- )
    :M  ^ELEM: ?Idx   ^elem        ;M   ( index -- addr )

    \ Leave max #elements for array
    :M  LIMIT: ?ixObj limit  ;M    ( -- limit )

    \ ( e0 e1... en -- )  indexed PUT: loads array from stack
    :M  PUT:   ?ixObj limit 0
        DO   limit i- 1- (^elem) !  LOOP   ;M
    \ ( -- e0 e1 ...en)  Indexed GET: places elements on stack
    :M  GET:   ?ixObj limit 0 DO i at4  LOOP ;M

    :M  CLASS: copym  cfa  @  ;M    \  non-IX - leave class ptr

    \ ( -- addr len )  leave class name string for object
    :M  WIDTH: ?ixObj  idxBase  4-  W@  ;M    \ IX - element size for array

    \ ( value -- )  Fill all elements with a value
    :M  FILL:  limit 0 DO  dup i to: self     LOOP drop   ;M

    \ ( -- )  Indexed Clear: erases indexed area
    :M  CLEAR:  idxBase  Width: self Limit: Self * Erase ;M

    :M  ABS:       (abs)   ;M    \  Absolute copy of mstack
    :M  ADDR:      copym   ;M

    \ ( -- addr )  Leave addr of 0th indexed element
    :M  IXADDR:    idxBase   ;M

    \ ( -- len )  Return total length of object
    :M  LENGTH:    objlen      ;M
    :M  PRINT:     copym objlen dmp ;M
    :M  DUMP:      print: self  ;M    \ alias for Print:
    :M  CLASSINIT:    ;M    \ null method for object init

;CLASS

\ Bytes is used as the allocation primitive for basic classes
: BYTES  ?Class  ' Object <Var  ^Class Dfa W+!  ;

\ define code words to get and set handle sizes
\ ( handle size -- RC )  set handle size with condition code
Create setHSize
    popD0
    popA0
    $ a024 w,    \ call SetHandleSize
    pushD0
    next,

\ ( handle -- size )  get handle size
Create getHSize
    popA0
    $ a025 w,    \ call GetHandleSize
    pushD0
    next,

<" Struct